home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 176-200 / disk_176 / hypernet / hypernet.for < prev    next >
Text File  |  1992-05-06  |  7KB  |  244 lines
  1. C compilation:
  2. C f77 -k -h -u -* HyperNet.for
  3. C link:
  4. C f77l -y hypernet amiga.sub
  5. C
  6. C SIMPLE-MINDED HYPERTEXT ON TERMINALS
  7. C DRIVEN OFF A FILE OF FORM
  8. C   +NODENAME
  9. C   $(ANY ACTION COMMAND TO BE SPAWNED) (or start with & for spawn/nowait)
  10. C   >NEXT-NODE-1
  11. C   >NEXT-NODE-2
  12. C   >NEXT-NODE-3
  13. C    ...
  14. C  REPEATED FOR LOTS OF NODES.
  15. C By Glenn Everhart
  16. C 25 Sleigh Ride Rd
  17. C Glen Mills PA 19342
  18. C
  19. C Public domain...use & enjoy.
  20. C  gce 9/3/1988
  21.     INTEGER*4 ISTAT,IFLG
  22.         Integer*4 ScrCnt
  23. C USE LIB$SPAWN TO EMIT COMMANDS. SLOW BUT THIS IS A KLUDGE DEMO
  24. C WHICH WILL BE A FIRST STEP ONLY.
  25.     INCLUDE DOS.INC
  26.     INTEGER*4 AMIGA
  27.     CHARACTER*128 CMDC
  28.     CHARACTER*1 CMD(128)
  29.     EQUIVALENCE (CMDC,CMD(1))
  30. C ALLOWS US TO WORK WITH CHARS OF COMMAND PROGRAMMATICALLY
  31.     CHARACTER*1 FILRD(128)
  32.     CHARACTER*128 FILC
  33.     EQUIVALENCE (FILC,FILRD(1))
  34. C ALLOWS READING LINES OF TEXT.
  35.     Character*128 FilNam
  36.     CHARACTER*128 CURNODE
  37.     CHARACTER*128 SUCCNODE(16)
  38. C ALLOW UP TO 16 SUCCESSOR NODES.
  39. C
  40. C OPEN THE CONSOLE
  41. C    OPEN(UNIT=5,FILE='SYS$INPUT',CARRIAGECONTROL='NONE',
  42. C     1  status='OLD')
  43. C    OPEN(UNIT=6,FILE='SYS$OUTPUT',CARRIAGECONTROL='NONE',
  44. C     1  status='new')
  45. C FORGET ABOUT FORTRASH CARRIAGE CONTROLS.
  46. C SET UP CURRENT NODE AS "START"
  47.     IFLG=1
  48.         Call CPut('Compiled by Absoft Fortran 2.3',30)
  49.     call cclr
  50.     call cpos(1,1)
  51.     call cput('Enter filename of data file:',28)
  52.     call cget(filnam,IFNSZ)
  53.     call cpos(2,1)
  54.     call cput('Pause before menus [Y/N]:',25)
  55.     ipaus=0
  56.     call cget(filc,iii)
  57.         ScrCnt=0
  58.     if(filc(1:1).eq.'y'.or.filc(1:1).eq.'Y')ipaus=1
  59. 998    CONTINUE
  60.     CURNODE='+START' // CHAR(0)
  61. 1000    CONTINUE
  62. C OPEN THE DATA FILE.
  63. C MUST HAVE NODENAME START SOMEPLACE.
  64.     OPEN(1,FILE=FilNam(1:IFNSZ),ACCESS='Sequential',
  65.      1   FORM='FORMATTED',STATUS='OLD')
  66. 1050    CONTINUE
  67. C READ THE DATA FILE UNTIL WE FIND CURRENT NODE DESIRED.
  68.     READ(1,100,END=9000)FILC
  69. 100    FORMAT(A)
  70.     If(Filc(1:1).ne.'+')goto 1050
  71.     IF(ICMPST(CURNODE,FILC).EQ.0)GOTO 1050
  72. C GOT THE NODE.
  73. C NOW READ THE COMMAND TO EXECUTE.
  74.     READ(1,100,END=9990)CMDC
  75.     ISUC=1
  76.     IF(CMDC(1:1).NE.'$'.and.CMDC(1:1).ne.'&'
  77.      1     .AND.CMDC(1:1).EQ.'>')THEN
  78.       ISUC=2
  79.       SUCCNODE(1)=CMDC
  80.     END IF
  81.     MXSUC=ISUC-1
  82.     DO 2000 I=ISUC,16
  83. C AT MOST 16 SUCCESSOR NODES
  84.     READ(1,100,END=2020)FILC
  85.     IF(FILC(1:1).NE.'>')GOTO 2020
  86.     SUCCNODE(I)=FILC
  87.     MXSUC=MXSUC+1
  88. 2000    CONTINUE
  89. 2020    CONTINUE
  90.     CLOSE(UNIT=1)
  91. C ALLOW EDITS OF HYPERTEXT FILE TO TAKE EFFECT NEXT TIME VIA CLOSE/REOPEN.
  92. C NOTE WE CAN SPAWN/NOWAIT TO ALLOW MULTIPLE COMMANDS TO TAKE EFFECT.
  93. C
  94. C NOW ISSUE THE COMMAND. USE LIB$SPAWN HERE. A SLIGHT VARIATION WOULD
  95. C REQUIRE USING BOSS AND HANDLE SWITCHING VIA COMMANDS TO BOSS TO FIRE
  96. C UP THE APPLICATION. FOR NOW, DO IT VANILLA.
  97. C spawn with wait if $ seen, with nowait if & seen in col 1.
  98.     IIV=0
  99. C Absoft Fortran seems to have trouble firing off some commands
  100. C directly, so fire off from a newcli, and use a short file in
  101. C ram: to hold the actual command, whatever it may be.
  102. C
  103. C Also arrange for scratch file name to have 0-9 added so that
  104. C the system will not have to re-use names before they have become
  105. C freed. Kludge, but easier than a complete solution, which might
  106. C involve something like ending via a transfer to a command file that
  107. C will delete all tmp.jnk#? files in ram: that it can.
  108.         ScrCnt=Mod(ScrCnt+1,10)
  109.         filc='Ram:Tmp.Jnk'//char(ScrCnt+48) // char(0)
  110.     OPEN(2,FILE=filc)
  111.     REWIND 2
  112.     If(Cmdc(2:2).ne.'&')GoTo 228
  113. C last-minute add-on
  114. C if SECOND character of command line is &, then have an automatic
  115. C  ENDCLI generated after the user's command.
  116.         Write(2,222)Cmdc(3:127)
  117.         Write(2,227)
  118. 227     Format('Endcli')
  119. 228     Continue
  120.         WRITE(2,222)CMDC(2:127)
  121. 229     Continue
  122. 222    Format(A)
  123.     CLOSE (UNIT=2)
  124.         If(cmdc(1:1).ne.'$'.and.Cmdc(1:1).ne.'&')goto 224
  125.         filc='NEWCLI CON:0/0/600/190/Hypnet FROM ram:Tmp.Jnk'
  126.      1   // char(ScrCnt+48) //  Char(0)
  127.         If(cmdc(1:1).eq.'&')filc='Newshell FROM ram:Tmp.Jnk' //
  128.      1  Char(ScrCnt+48) // Char(0)
  129.         ISTAT=AMIGA(EXECUTE,filc,IIV,IIV)
  130. 224     Continue
  131. C STRIPS OFF THE CRUFT AT THE START AND FIRES IT UP.
  132. C
  133. C NOW DISPLAY THE MENU AND GO TRY AGAIN.
  134.     CALL CPOS(24,1)
  135.     If(Ipaus.eq.1)CALL CPUT('Return when ready for menu:',27)
  136.     If(Ipaus.eq.1)Call CGET(filc,iiii)
  137.     Call CCLR
  138. C clear screen
  139.     Call CPOS(1,1)
  140. C go to top left
  141.     If(Mxsuc.lt.1)goto 998
  142.     do 2500 i=1,MXSUC
  143.     write(filc(1:2),2501)i
  144. 2501    format(i2)
  145.     cmdc=filc(1:2)//' '//succnode(i)(2:76)
  146.     Call cpos(i,2)
  147.     Call CPUT(cmdc,78)
  148. 2500    Continue
  149. C Now get his reply for selection. Do by number for the
  150. C time being, since that's the simplest way to do it.
  151. 2504    Continue
  152.     cmdc=' '
  153.     Call CPOS(20,10)
  154. C move to line 20, col 10
  155.     Call CPUT('Enter choice (number):',22)
  156.     Call CGET(cmdc,iii)
  157.     read(cmdc,2503,err=9990,end=9990)i
  158. 2503    Format(bn,I2)
  159. C Edit this format if we allow more choices than 99 in the future
  160. C Loop back if his reply is out of range for this.
  161.     If(i.eq.99)goto 998
  162.     If(i.eq.98)goto 9990
  163. C restart on an input of 99
  164.     If(i.lt.0.or.i.gt.MXSUC) goto 2504
  165. C Got a valid (apparently) choice.
  166. C Make it the new current node and go back.
  167.     CURNODE=SUCCNODE(I)
  168.     Curnode(1:1)='+'
  169. C Fix up with + in col 1 so we need not mask this stuff off.
  170.     GOTO 1000
  171. 9000    CONTINUE
  172.     CALL CCLR
  173.     CALL CPOS(6,4)
  174.     CALL CPUT('UNKNOWN NODE. RESTARTING.',25)
  175.     CLOSE(UNIT=1)
  176.     GOTO 998
  177. 9990    CONTINUE
  178.     Close(unit=1)
  179. c be sure lun 1 is closed...safety.
  180.     STOP 'End HyperNet'
  181.     END
  182.     SUBROUTINE CGET(STRING,LEN)
  183. C GET A CHARACTER STRING IN WITH ITS LENGTH
  184.     CHARACTER*80 STRING
  185.     INTEGER*4 LEN
  186.     READ(*,100)STRING
  187. 100    FORMAT(A)
  188.     DO 1 N=1,80
  189.     NN=81-N
  190.     IF(ICHAR(STRING(NN:NN)).GT.32)GOTO 2
  191. 1    CONTINUE
  192. 2    CONTINUE
  193.     LEN=NN
  194.     RETURN
  195.     END
  196.     SUBROUTINE CPUT(STRING,LEN)
  197. C    WRITE STRING OF LENGTH "LEN"
  198.     CHARACTER*128 STRING
  199.     INTEGER*4 LEN
  200.     WRITE(*,100)STRING(1:LEN)
  201. 100    FORMAT(A)
  202.     RETURN
  203.     END
  204.     SUBROUTINE CPOS(IR,IC)
  205. C MOVE TO ROW IR, COL IC
  206.     INTEGER*4 IR,IC
  207.     CHARACTER*3 CR,CC
  208.     CHARACTER*1 IE
  209.     IE=CHAR(27)
  210.     WRITE(CR,1)IR
  211. 1    FORMAT(I3.3)
  212.     WRITE(CC,1)IC
  213.     WRITE(*,2)IE,CR,CC
  214. 2    FORMAT(A,'[',A,';',A,'H')
  215.     RETURN
  216.     END
  217.     SUBROUTINE CCLR
  218. C CLEAR DISPLAY
  219.     CHARACTER*1 IE
  220.     IE=CHAR(27)
  221.         WRITE(*,1)IE,IE
  222. 1    FORMAT(A,'[H',A,'[J')
  223.     RETURN
  224.     END
  225.     FUNCTION ICMPST(STRING1,STRING2)
  226.     CHARACTER*128 STRING1,STRING2
  227. C COMPARE TWO STRINGS, STOPPING ON NULL TERMINATORS
  228.     INTEGER*4 IRS
  229.     IRS=1
  230.     DO 100 I=1,128
  231.     IF(ICHAR(STRING1(I:I)).LE.32)GOTO 100
  232.     IF(ICHAR(STRING2(I:I)).LE.32)GOTO 100
  233.     IF(ICHAR(STRING1(I:I)).LE.0)GOTO 300
  234.     IF(ICHAR(STRING2(I:I)).LE.0)GOTO 300
  235.     IF(STRING1(I:I).NE.STRING2(I:I))GOTO 200
  236. 100    CONTINUE
  237.     GOTO 300
  238. 200    CONTINUE
  239.     IRS=0
  240. 300    CONTINUE
  241.     ICMPST=IRS
  242.     RETURN
  243.     END
  244.